home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / xlispst.cpt / XLisp-Stat ƒ / Disk 1 / graphics2.lsp < prev    next >
Encoding:
Text File  |  1990-07-24  |  18.2 KB  |  494 lines
  1. (provide "graphics2")
  2. (require "graphics")
  3.  
  4. ;;;;
  5. ;;;;
  6. ;;;; Scatmat Object Prototype
  7. ;;;;
  8. ;;;;
  9.  
  10. (send scatmat-proto :title "Scatterplot Matrix")
  11. (send scatmat-proto :menu-title "Scatmat")
  12. (send scatmat-proto :fixed-aspect t)
  13. (send scatmat-proto :menu-template (send graph-proto :menu-template))
  14.  
  15. ;;;;
  16. ;;;;
  17. ;;;; Spinner Object Prototype
  18. ;;;;
  19. ;;;;
  20.  
  21. (send spin-proto :title "Spinning Plot")
  22. (send spin-proto :menu-title "Spinner")
  23. (send spin-proto :fixed-aspect t)
  24. (send spin-proto :menu-template (append (send graph-proto :menu-template)
  25.                                         '(dash faster slower cuing axes)))
  26. (send spin-proto :variable-labels '("X" "Y" "Z"))
  27. (send spin-proto :black-on-white nil)
  28. (send spin-proto :depth-cuing t)
  29. (send spin-proto :showing-axes t)
  30. (send spin-proto :scale-type 'variable)
  31.                                         
  32. (defmeth spin-proto :isnew (&rest args)
  33.   (apply #'call-next-method args)
  34.   (send self :add-overlay (send spin-control-overlay-proto :new)))
  35.  
  36. (defmeth spin-proto :adjust-to-data (&key (draw t))
  37.   (call-next-method :draw nil)
  38.   (when (null (send self :scale-type))
  39.         (let* ((vars (send self :num-variables))
  40.                (ranges (send self :range (iseq 0 (- vars 1))))
  41.                (radius (* (sqrt vars)
  42.                           (max (- (min ranges)) (max ranges)))))
  43.           (send self :center (iseq vars) 0 :draw nil)
  44.           (send self :range (iseq vars) (- radius) radius :draw nil)))
  45.   (when draw
  46.         (send self :resize)
  47.         (send self :redraw)))
  48.  
  49. (defmeth spin-proto :rotation-type (&optional (new nil set))
  50.   (if set (setf (slot-value 'rotation-type) new))
  51.   (slot-value 'rotation-type))
  52.  
  53. (defmeth spin-proto :make-menu-item (item)
  54.   (if (symbolp item)
  55.       (case item
  56.         (faster (send spin-speed-item-proto :new self 1.5))
  57.         (slower (send spin-speed-item-proto :new self (/ 2 3)))
  58.         (cuing  (send graph-item-proto :new "Depth Cuing" self
  59.                       :depth-cuing :depth-cuing :toggle t :redraw t))
  60.         (axes   (send graph-item-proto :new "Show Axes" self
  61.                       :showing-axes :showing-axes :toggle t :redraw t))
  62.         (t (call-next-method item)))
  63.       item))
  64.       
  65. (defmeth spin-proto :add-surface (x y z &key (draw t) (type 'solid) (spline 3))
  66. "Args: (x y z &key (draw t) (type 'solid) (spline 3))
  67. Adds a grid surface using sequences X, Y with values in the matrix Z.
  68. Z should be (length X) by (length Y)."
  69.   (let ((z (row-list z)))
  70.     (mapcar #'(lambda (u z) 
  71.                (let* ((yz (if spline
  72.                               (spline y z :xvals (* spline (length y)))
  73.                               (list y z)))
  74.                       (y (first yz))
  75.                       (z (second yz)))
  76.                  (send self
  77.                        :add-lines 
  78.                        (list (repeat u (length y)) y z) 
  79.                        :draw nil :type type)))
  80.             x z))
  81.   (let ((z (column-list z)))
  82.     (mapcar #'(lambda (u z)
  83.                 (let* ((xz (if spline 
  84.                                (spline x z :xvals (* spline (length x)))
  85.                                (list x z)))
  86.                        (x (first xz))
  87.                        (z (second xz)))
  88.                   (send self
  89.                         :add-lines 
  90.                         (list x (repeat u (length x)) z)
  91.                         :draw nil :type type)))
  92.             y z))
  93.   (if draw (send self :redraw))
  94.   nil)
  95.   
  96. (defmeth spin-proto :add-function (f xmin xmax ymin ymax &rest args &key (num-points 6))
  97. "Args: (f xmin xmax ymin ymax &rest args &key (num-points 6))
  98. Adds surface of function F over a NUM-POINTS by NUM-POINTS grid on the
  99. rectangle [xmin, xmax] x [ymin, ymax]. Passes other keywords to
  100. :add-surface method."
  101.   (let* ((x (rseq xmin xmax num-points))
  102.          (y (rseq ymin ymax num-points))
  103.          (z (outer-product x y f)))
  104.     (apply #'send self :add-surface x y z args)))
  105.   
  106. (defmeth spin-proto :abcplane (a b c)
  107. "Message args: (a b c)
  108. Adds the graph of the plane A + B x + Cy to the plot."
  109.   (let ((xlimits (send self :range 0))
  110.         (ylimits (send self :range 1)))
  111.     (send self :add-function #'(lambda (x y) (+ a (* b x) (* c y)))
  112.           (- (mean xlimits) (/ (abs (apply #'- xlimits)) (* 2 (sqrt 3))))
  113.           (+ (mean xlimits) (/ (abs (apply #'- xlimits)) (* 2 (sqrt 3))))
  114.           (- (mean ylimits) (/ (abs (apply #'- ylimits)) (* 2 (sqrt 3))))
  115.           (+ (mean ylimits) (/ (abs (apply #'- ylimits)) (* 2 (sqrt 3))))
  116.           :spline nil)))
  117.  
  118. ;;
  119. ;; Spinner control overlay
  120. ;;
  121.  
  122. (defproto spin-control-overlay-proto 
  123.           '(top lefts gap side ascent box-top text-base)
  124.           ()
  125.           graph-overlay-proto)
  126.  
  127. (defmeth spin-control-overlay-proto :isnew ()
  128.   (setf (slot-value 'gap) 5)
  129.   (setf (slot-value 'side) 10)
  130.   (setf (slot-value 'ascent) (send graph-proto :text-ascent))
  131.   (let ((w1 (send graph-proto :text-width "Pitch"))
  132.         (w2 (send graph-proto :text-width "Roll"))
  133.         (w3 (send graph-proto :text-width "Yaw"))
  134.         (gap (slot-value 'gap))
  135.         (side (slot-value 'side)))
  136.     (setf (slot-value 'lefts)
  137.           (list (* 2 gap)
  138.                 (+ (* 3 gap) side)
  139.                 (+ (* 6 gap) (* 2 side) w1)
  140.                 (+ (* 7 gap) (* 3 side) w1)
  141.                 (+ (* 11 gap) (* 4 side) w1 w2)
  142.                 (+ (* 12 gap) (* 5 side) w1 w2)))))
  143.  
  144. (defmeth spin-control-overlay-proto :resize ()
  145.   (let* ((graph (send self :graph))
  146.          (height (send graph :canvas-height))
  147.          (bottom-margin (fourth (send graph :margin)))
  148.          (top (+ (- height bottom-margin) 1))
  149.          (gap (slot-value 'gap))
  150.          (side (slot-value 'side))
  151.          (ascent (send graph :text-ascent))
  152.          (text-base (+ top gap (max side ascent)))
  153.          (box-top (- text-base side)))
  154.     (setf (slot-value 'top) top)
  155.     (setf (slot-value 'text-base) text-base)
  156.     (setf (slot-value 'box-top) box-top)))
  157.  
  158. (defmeth spin-control-overlay-proto :redraw ()
  159.   (let ((graph (slot-value 'graph))
  160.         (top (slot-value 'top))
  161.         (lefts (slot-value 'lefts))
  162.         (gap (slot-value 'gap))
  163.         (side (slot-value 'side))
  164.         (text-base (slot-value 'text-base))
  165.         (box-top (slot-value 'box-top)))
  166.     (send graph :draw-line 0 top (send graph :canvas-width) top)
  167.     (mapcar #'(lambda (x) (send graph :frame-rect x box-top side side))
  168.             lefts)
  169.     (mapcar #'(lambda (s x y) (send graph :draw-string s x y))
  170.             '("Pitch" "Roll" "Yaw")
  171.             (+ (select lefts '(1 3 5)) gap side) 
  172.             (repeat text-base 3))))
  173.  
  174. (defmeth spin-control-overlay-proto :do-click (x y m1 m2)
  175.   (let ((graph (slot-value 'graph))
  176.         (top (slot-value 'top))
  177.         (lefts (slot-value 'lefts))
  178.         (gap (slot-value 'gap))
  179.         (side (slot-value 'side))
  180.         (text-base (slot-value 'text-base))
  181.         (box-top (slot-value 'box-top)))
  182.     (when (< top y)
  183.           (send graph :idle-on nil)
  184.           (if (< box-top y text-base)
  185.               (let ((i (car (which (< lefts x (+ lefts side)))))
  186.                     (angle (abs (send graph :angle))))
  187.                 (when i
  188.                       (send graph :rotation-type 
  189.                             (select '(pitching rolling yawing)
  190.                                     (floor (/ i 2))))
  191.                       (send graph :angle (if (oddp i) angle (- angle)))
  192.                       (send graph :while-button-down
  193.                             #'(lambda (x y) (send graph :rotate))
  194.                             nil)
  195.                       (send graph :idle-on m1))))
  196.           t)))
  197.  
  198.  
  199. ;;
  200. ;; Spinner Menu Items
  201. ;;
  202.  
  203. ;; SPIN-SPEED-ITEM-PROTO. multiply speed by fixed number to speed up or slow down. 
  204. (defproto spin-speed-item-proto '(graph mult) () menu-item-proto)
  205.  
  206. (defmeth spin-speed-item-proto :isnew (v m)
  207.   (setf (slot-value 'graph) v)
  208.   (setf (slot-value 'mult) m)
  209.   (call-next-method (if (> 1 m) "Slower" "Faster"))
  210.   (send self :key (if (> 1 m) #\S #\F)))
  211.   
  212. (defmeth spin-speed-item-proto :do-action ()
  213.   (send (slot-value 'graph) :angle (* (slot-value 'mult) (send (slot-value 'graph) :angle))))
  214.  
  215.  
  216. ;;;;
  217. ;;;;
  218. ;;;; Spinner Functions
  219. ;;;;
  220. ;;;;
  221.  
  222. (defun spin-function (f xmin xmax ymin ymax &rest args)
  223. "Args: (f xmin xmax ymin ymax &key (num-points 6) (spline 3))
  224. Rotatable plot of function F of two real variables over the range
  225. between [xmin, xmax] x [ymin, ymax]. The function is evaluated at
  226. NUM-POINTS points. If SPLINE is not NIL a spline is fit at 
  227. (* SPLINE NUMPOINTS) points."
  228.   (let ((plot (apply #'send spin-proto :new 3 :show nil args)))
  229.     (apply #'send plot :add-function f xmin xmax ymin ymax :draw nil args)
  230.     (send plot :adjust-to-data :draw nil)
  231.     (send plot :new-menu)
  232.     (send plot :showing-axes nil)
  233.     (send plot :rotate-2 0 1 (/ pi 3) :draw nil)
  234.     (send plot :rotate-2 1 2 (- (/ pi 3)) :draw nil)
  235.     (send plot :show-window)
  236.     plot))
  237.  
  238. ;;;;
  239. ;;;;
  240. ;;;; Name List Object Prototype
  241. ;;;;
  242. ;;;;
  243.  
  244. (send name-list-proto :title "Name List")
  245. (send name-list-proto :menu-title "List")
  246. (send name-list-proto :menu-template '(link mouse dash erase-selection 
  247.                                             focus-on-selection show-all
  248. #+color                                     color
  249.                                             selection dash options
  250. #-macintosh                                 save-image))
  251.  
  252. ;;;;
  253. ;;;;
  254. ;;;; Histogram Object Prototype
  255. ;;;;
  256. ;;;;
  257.  
  258. (send histogram-proto :title "Histogram")
  259. (send histogram-proto :menu-title "Histogram")
  260. (send histogram-proto :fixed-aspect nil)
  261. (send histogram-proto :size 250 125)
  262. (send histogram-proto :menu-template '(link mouse resize-brush dash 
  263.                                             erase-selection
  264.                                             focus-on-selection show-all
  265. #+color                                     color
  266.                                             selection dash 
  267. #-small-machine                             slicer 
  268.                                             rescale 
  269. #-small-machine                             options 
  270. #-macintosh                                 save-image
  271.                                             dash change-bins))
  272.  
  273. (defmeth histogram-proto :make-menu-item (item)
  274.   (if (symbolp item)
  275.       (case item
  276.         (change-bins (send change-hist-bins-item-proto :new self))
  277.         (t (call-next-method item)))
  278.       item))
  279.       
  280. (defmeth histogram-proto :drag-point (x y &key (draw t))
  281.   (let ((p (call-next-method x y :draw nil)))
  282.     (if p (send self :resize))
  283.     (if (and p draw) (send self :redraw))
  284.     p))
  285.  
  286. ;;
  287. ;; Histogram Menu Items
  288. ;;
  289.  
  290. ;; CHANGE-HIST-BINS-ITEM-PROTO. Opens new integer dialog.
  291. (defproto change-hist-bins-item-proto '(graph) () menu-item-proto)
  292.  
  293. (defmeth change-hist-bins-item-proto :isnew (h)
  294.   (setf (slot-value 'graph) h)
  295.   (call-next-method "Change Bins"))
  296.  
  297. (defmeth change-hist-bins-item-proto :do-action ()
  298.   (let ((bins (get-new-integer "Number of bins"
  299.                                2
  300.                                30
  301.                                (send (slot-value 'graph) :num-bins))))
  302.     (when bins 
  303.           (send (slot-value 'graph) :num-bins bins)
  304.           (send (slot-value 'graph) :redraw))))
  305.  
  306. ;;;;
  307. ;;;;
  308. ;;;; Scatterplot Object Prototype
  309. ;;;;
  310. ;;;;
  311.  
  312. (send scatterplot-proto :title "Plot")
  313. (send scatterplot-proto :menu-title "Plot")
  314. (send scatterplot-proto :fixed-aspect nil)
  315. (send scatterplot-proto :menu-template (send graph-proto :menu-template))
  316.  
  317. (defmeth graph-proto :add-function (f xmin xmax &rest args &key (num-points 50))
  318. "Message args: (f xmin xmax &key (num-points 50)
  319. Adds plot of function F of one real variable over the range between xmin
  320. and xmax to the plot. The function is evaluated at NUM-POINTS points."
  321.   (unless (= 2 (send self :num-variables)) (error "only works for 2D plots"))
  322.   (let* ((x (rseq xmin xmax num-points))
  323.          (y (mapcar f x)))
  324.     (apply #'send self :add-lines (list x y) args)))
  325.  
  326. (defmeth graph-proto :abline (a b)
  327. "Message args: (a b)
  328. Adds the graph of the line A + B x to the plot."
  329.   (let ((limits (send self :range 0)))
  330.     (send self :add-function #'(lambda (x) (+ a (* b x)))
  331.           (car limits)
  332.           (cadr limits))))
  333.  
  334. (defmeth graph-proto :plotline (a b c d draw)
  335.   (send self :add-lines (list a c) (list b d) :draw draw))
  336.  
  337. ;;;;
  338. ;;;;
  339. ;;;; Basic 2D Plotting Functions
  340. ;;;;
  341. ;;;;
  342.  
  343. (defun plot-function (f xmin xmax &key (num-points 50) (type 'solid) labels)
  344. "Args: (f xmin xmax &optional (num-points 50) labels)
  345. Plots function F of one real variable over the range between xmin and xmax.
  346. The function is evaluated at NUM-POINTS points. LABELS is a list of axis
  347. labels."
  348.   (let* ((x (rseq xmin xmax num-points))
  349.          (y (mapcar f x)))
  350.     (plot-lines x y :type type :variable-labels labels)))
  351.  
  352. ;;;;
  353. ;;;;
  354. ;;;; Boxplot  Functions
  355. ;;;;
  356. ;;;;
  357.  
  358. (defmeth scatterplot-proto :add-boxplot (y &key (x 1.0) (width 1.0) (draw t))
  359.   (unless (= 2 (send self :num-variables)) (error "only works for 2D plots"))
  360.   (let* ((half-box (* 0.4 width))
  361.          (half-foot (* 0.1 width))
  362.          (fiv (fivnum y))
  363.          (low (select fiv 0))
  364.          (q1 (select fiv 1))
  365.          (med (select fiv 2))
  366.          (q3 (select fiv 3))
  367.          (high (select fiv 4)))
  368.     (send self :plotline (- x half-foot) low  (+ x half-foot) low  nil)
  369.     (send self :plotline (- x half-foot) high (+ x half-foot) high nil)
  370.     (send self :plotline x low x q1   nil)
  371.     (send self :plotline x q3  x high nil)
  372.     (send self :plotline (- x half-box) q1  (+ x half-box) q1  nil)
  373.     (send self :plotline (- x half-box) med (+ x half-box) med nil)
  374.     (send self :plotline (- x half-box) q3  (+ x half-box) q3  nil)
  375.     (send self :plotline (- x half-box) q1  (- x half-box) q3  nil)
  376.     (send self :plotline (+ x half-box) q1  (+ x half-box) q3  nil)))
  377.  
  378. (defun boxplot (data &key (title "Box Plot"))
  379. "Args: (data &key (title \"Box Plot\"))
  380. DATA is a sequence, a list of sequences or a matrix. Makes a boxplot of the
  381. sequence or a parallel box plot of the sequences in the list or the columns
  382. of the matrix." 
  383.   (let ((p (send scatterplot-proto :new 2 :title title :show nil)))
  384.     (setq data 
  385.           (cond ((matrixp data) (column-list data))
  386.                 ((or (not (listp data)) (numberp (car data))) (list data))
  387.                 (t data)))
  388.         (let ((range (get-nice-range (min data) (max data) 4)))
  389.           (send p :range 1 (nth 0 range) (nth 1 range))
  390.           (send p :y-axis t nil (nth 2 range)))
  391.     (send p :range 0 0 (1+ (length data)))
  392.     (dotimes (i (length data))
  393.           (send p :add-boxplot (nth i data) :x (1+ i)))
  394.     (send p :show-window)
  395.     p))
  396.  
  397. (defun boxplot-x (x data &key (title "Box Plot"))
  398. "Args: (x data &key (title \"Box Plot\"))
  399. DATA is a list of sequences or a matrix. X is a sequence with as many
  400. elements as DATA has elements or columns. Makes a parallel box plot
  401. of the sequences in the list or the columns of the matrix vs X." 
  402.   (let ((p (send scatterplot-proto :new 2 :title title :show nil)))
  403.     (setq data 
  404.           (cond ((matrixp data) (column-list data))
  405.                 ((or (not (listp data)) (numberp (car data))) (list data))
  406.                 (t data)))
  407.         (let ((range (get-nice-range (min data) (max data) 4)))
  408.           (send p :range 1 (nth 0 range) (nth 1 range))
  409.           (send p :y-axis t nil (nth 2 range)))
  410.     (setq x (coerce x 'list))
  411.     (if (/= (length x) (length data)) (error "argument lengths do not match"))
  412.     (let* ((width (min (difference x)))
  413.            (range (get-nice-range (- (min x) width) (+ (max x) width) 4)))
  414.       (send p :range 0 (nth 0 range) (nth 1 range))
  415.       (send p :x-axis t nil (nth 2 range))
  416.       (dotimes (i (length data))
  417.                (send p :add-boxplot (nth i data) :width width :x (nth i x))))
  418.     (send p :show-window)
  419.     p))
  420.  
  421. ;;;;
  422. ;;;;
  423. ;;;; Quantile and Probability Plot Functions
  424. ;;;;
  425. ;;;;
  426.  
  427. (defun quantile-plot (x &key (quantile-function #'normal-quant) 
  428.                         (title "Quantile Plot") point-labels)
  429. "Args: (data &key (quantile-function #'normal-quant) (title \"Quantile Plot\") point-labels)"
  430.   (plot-points (funcall quantile-function
  431.                         (/ (1+ (rank x)) (1+ (length x))))
  432.                x
  433.                :title title 
  434.                :axis-labels
  435.                '("Theoretical Quantiles" "Observed Quantiles")
  436.                :point-labels point-labels))
  437.  
  438. (defun probability-plot (x &key (distribution-function #'normal-cdf)
  439.                            (title "Probability Plot") point-labels)
  440. "Args: (data &key (distribution-function #'normal-cdf) (title \"Probability Plot\") point-labels)"
  441.   (let ((p (plot-points (/ (1+ (rank x)) (1+ (length x)))
  442.                                 (funcall distribution-function x)
  443.                                 :title title
  444.                                 :variable-labels '("Theoretical CDF" "Observed CDF")
  445.                                 :point-labels point-labels)))
  446.     (send p :x-axis t t 5)
  447.     (send p :y-axis t t 5)
  448.     p))
  449.  
  450. ;;;;
  451. ;;;;
  452. ;;;; Contour Plotting Methods and Functions
  453. ;;;;
  454. ;;;;
  455.  
  456. (defmeth scatterplot-proto :add-surface-contour (x y z v &key (draw t))
  457.   (let ((c (surface-contour x y z v)))
  458.     (dolist (x (split-list c 2))
  459.             (send self :add-lines (transpose x) :draw nil)))
  460.     (if draw (send self :redraw-content)))
  461.     
  462. (defmeth scatterplot-proto :add-surface-contours 
  463.          (x y z &optional v &key (draw t))
  464.   (let ((v (if v 
  465.                (if (numberp v) (list v v) (coerce v 'list))
  466.                (let ((min (min z))
  467.                      (max (max z)))
  468.                  (+ min (* (- max min) '(.2 .4 .6 .8)))))))
  469.     (dolist (v v) (send self :add-surface-contour x y z v :draw nil))
  470.     (if draw (send self :redraw-content))))
  471.  
  472. (defmeth scatterplot-proto :add-function-contours 
  473.          (f xmin xmax ymin ymax &optional v &key (num-points 6) (draw t))
  474.   (let* ((x (coerce (rseq xmin xmax num-points) 'vector))
  475.          (y (coerce (rseq ymin ymax num-points) 'vector))
  476.          (z (outer-product x y f)))
  477.     (send self :add-surface-contours x y z v :draw draw)))
  478.  
  479. (defun contour-function (f xmin xmax ymin ymax &rest args
  480.                            &key levels (num-points 6))
  481. "Args: (f xmin xmax ymin ymax &key levels (num-points 6))
  482. Contour plot of function F of two real variables over the range
  483. between [xmin, xmax] x [ymin, ymax]. The function is evaluated at
  484. NUM-POINTS points."
  485.   (let ((plot (apply #'send scatterplot-proto :new 2 :show nil args)))
  486.     (send plot :add-function-contours f xmin xmax ymin ymax 
  487.           levels :num-points num-points :draw nil)
  488.     (send plot :adjust-to-data :draw nil)
  489.     (send plot :new-menu)
  490.     (send plot :show-window)
  491.     plot))
  492.  
  493. #-small-machine (require "graphics3")
  494.